home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Source Code / Add-Ons / MPW / MPW noweb 2.7 / src / perl / noidx < prev    next >
Encoding:
Text File  |  1995-10-04  |  11.0 KB  |  495 lines  |  [TEXT/MPS ]
  1. Perl -Sx "{0}" {"Parameters"}; Exit 
  2. #!perl
  3.  
  4. while ($arg = shift @ARGV) {
  5.     if ($arg eq "-delay") {
  6.     $delay = 1;
  7.     } elsif ($arg eq "-docanchor") {
  8.     $anchordist = shift @ARGV;
  9.     } else {
  10.     die "This can't happen -- $1 passed to noidx";
  11.     }
  12. }
  13.  
  14. $[ = 1;            # set array base to 1
  15. $, = ' ';        # set output field separator
  16. $\ = "\n";        # set output record separator
  17.  
  18. $curfile = 'standard input?';
  19. $lastchunkbegin = 'never any chunks?';
  20. $allchunks{0} = 0;
  21. $allidents{0} = 0;
  22. $indexlabels{0} = 0;
  23. $defanchors{0} = 0;
  24. $uses{0} = 0;
  25. $anchorlabel{0} = 0;
  26. $indexanchorlabel{0} = 0;
  27. $thesedefns{0} = 0;
  28. $theseuses{0} = 0;
  29. $defcount{0} = 0;
  30. $udlist{0} = 0;
  31. $uidtable{0} = 0;
  32. $keycounts{0} = 0;
  33. $sorted{0} = 0;
  34. $sortkeys{0} = 0;
  35. $alphacodes = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
  36. $alphacodelen = length($alphacodes);
  37. $nextline = 0;
  38.  
  39. while (<>) {
  40.     chop;    # strip record separator
  41.     if (/^\@file /) {
  42.     $curfile = &uniqueid(substr($_, 7, 999999));
  43.     }
  44.     if (/^\@begin /) {
  45.     $lastchunkbegin = $_;
  46.     }
  47.     if (/^\@end docs /) {
  48.     if ($anchordist > 0) {
  49.         $n = $anchordist;
  50.         $lastanchorlabel = &newdocslabel();
  51.         for ($i = $nextline - 1; $i >= 0; $i--) {
  52.         if ($n == 0 || $lines{$i} =~ /^\@begin docs /) {
  53.             &insertafter($i, '@xref label ' . $lastanchorlabel);
  54.             $i = -1;# cause loop to terminate
  55.  
  56.             ;
  57.         }
  58.         elsif ($lines{$i} eq '@nl') {
  59.             $n--;
  60.         }
  61.         }
  62.     }
  63.     }
  64.     if (/^\@end code /) {
  65.     $lastanchorlabel = '';
  66.     }
  67.     if (/^\@defn /) {
  68.     $arg = substr($_, 7, 999999);
  69.     $allchunks{$arg} = 1;
  70.     $lastdefnlabel = &newdefnlabel($arg);
  71.     &slipin('@xref label ' . $lastdefnlabel);
  72.     if ($lastanchorlabel eq '') {
  73.         $lastanchorlabel = $lastdefnlabel;
  74.     }
  75.     if ($anchorlabel{$arg} eq '') {
  76.         $anchorlabel{$arg} = $lastanchorlabel;
  77.     }
  78.     &addlabel(*defanchors, $arg, $lastanchorlabel);
  79.     &addud(*chunkud, 'defn', $arg, $lastanchorlabel);
  80.     $thisusecount = 0;
  81.     }
  82.     if (/^\@use /) {
  83.     $arg = substr($_, 6, 999999);
  84.     $allchunks{$arg} = 1;
  85.     &slipin('@xref label ' . $lastdefnlabel . '-u' . (++$thisusecount));
  86.     &addlabel(*uses, $arg, $lastanchorlabel);
  87.     &addud(*chunkud, 'use', $arg, $lastanchorlabel);
  88.     }
  89.     if (/^\@index use /) {
  90.     $arg = substr($_, 12, 999999);
  91.     $allidents{$arg} = 1;
  92.     if ($lastanchorlabel ne '') {
  93.         &addud(*indexud, 'use', $arg, $lastanchorlabel);
  94.     }
  95.     }
  96.     if (/^\@index defn /) {
  97.     $arg = substr($_, 13, 999999);
  98.     $allidents{$arg} = 1;
  99.     if ($lastanchorlabel ne '') {
  100.         $l = $lastanchorlabel;
  101.     }
  102.     else {
  103.         $l = &newdocslabel();
  104.         &slipin('@xref label ' . $l);
  105.     }
  106.     &addud(*indexud, 'defn', $arg, $l);
  107.     if ($indexanchorlabel{$arg} eq '') {
  108.         $indexanchorlabel{$arg} = $l;
  109.     }
  110.     &slipin('@xref ref ' . $l);# bug fix
  111.     }
  112.     if (/^\@index localdefn /) {
  113.     $arg = substr($_, 18, 999999);
  114.     $allidents{$arg} = 1;
  115.     if ($lastanchorlabel ne '') {
  116.         $l = $lastanchorlabel;
  117.     }
  118.     else {
  119.         $l = &newdocslabel();
  120.         &slipin('@xref label ' . $l);
  121.     }
  122.     &addud(*indexud, 'defn', $arg, $l);
  123.     if ($indexanchorlabel{$arg} eq '') {
  124.         $indexanchorlabel{$arg} = $l;
  125.     }
  126.     &slipin('@xref ref ' . $l);# bug fix
  127.     }
  128.     $lines{$nextline} = $_;
  129.     $nextline++;
  130. }
  131.  
  132. for ($i = 0; $i < $nextline; $i++) {
  133.     $line = $lines{$i};
  134.     if ($line =~ /^\@begin /) {
  135.     if ($delay && $lastchunkbegin eq $line) {    
  136.         print '@nl';
  137.         print '@nl';
  138.         &lognowebchunks();
  139.         &lognowebindex();
  140.     }
  141.     print $line;
  142.     foreach $X (keys %thesedefns) {
  143.         delete $thesedefns{$X};
  144.     }
  145.     foreach $X (keys %theseuses) {
  146.         delete $theseuses{$X};
  147.     }
  148.     $thischunk = '';
  149.     }
  150.     elsif ($line =~ /^\@defn /) {
  151.     $thischunk = substr($line, 7, 999999);
  152.     printf "\@xref ref %s\n", $anchorlabel{$thischunk};
  153.     print $line;
  154.     }
  155.     elsif ($line =~ /^\@use /) {
  156.     $arg = substr($line, 6, 999999);
  157.     printf "\@xref ref %s\n",
  158.  
  159.       ($anchorlabel{$arg} eq '' ? 'nw\@notdef' : $anchorlabel{$arg});
  160.     print $line;
  161.     }
  162.     elsif ($line =~ /^\@index defn /) {
  163.     $arg = substr($line, 13, 999999);
  164.     $thesedefns{$arg} = 1;
  165.     # no xref ref because of bug fix
  166.     # if (indexanchorlabel[arg] != "") 
  167.     #   printf "\@xref ref %s\n", indexanchorlabel[arg]
  168.     print $line;
  169.     }
  170.     elsif ($line =~ /^\@index localdefn /) {
  171.     $arg = substr($line, 18, 999999);
  172.     $thesedefns{$arg} = 1;
  173.     # no xref ref because of bug fix
  174.     # if (indexanchorlabel[arg] != "") 
  175.     #   printf "\@xref ref %s\n", indexanchorlabel[arg]
  176.     print $line;
  177.     }
  178.     elsif ($line =~ /^\@index use /) {
  179.     $arg = substr($line, 12, 999999);
  180.     $theseuses{$arg} = 1;
  181.     if ($indexanchorlabel{$arg} ne '') {
  182.         printf "\@xref ref %s\n", $indexanchorlabel{$arg};
  183.     }
  184.     print $line;
  185.     }
  186.     elsif ($line =~ /^\@end code/) {
  187.     $defout{$thischunk}++;
  188.     foreach $X (keys %thesedefns) {
  189.         delete $theseuses{$X};
  190.     }
  191.     delete $thesedefns{0};
  192.     $n = &alphasort(*thesedefns);
  193.     if ($n > 0) {
  194.         print '@index begindefs';
  195.         for ($j = 0; $j < $n; $j++) {
  196.         $M = (@a = split(' ', $indexud{$sorted{$j}}));
  197.         for ($k = 1; $k <= $M; $k++) {
  198.             if ($a[$k] =~ /^use/) {
  199.             printf "\@index isused %s\n", substr($a[$k], 5,
  200.  
  201.               length($a[$k]) - 5);
  202.             }
  203.         }
  204.         printf "\@index defitem %s\n", $sorted{$j};
  205.         delete $sorted{$j};
  206.         }
  207.         print '@index enddefs';
  208.     }
  209.     delete $theseuses{0};
  210.     $n = &alphasort(*theseuses);
  211.     if ($n > 0) {
  212.         print '@index beginuses';
  213.         for ($j = 0; $j < $n; $j++) {
  214.         $M = (@a = split(' ', $indexud{$sorted{$j}}));
  215.         for ($k = 1; $k <= $M; $k++) {
  216.             if ($a[$k] =~ /^defn/) {
  217.             printf "\@index isdefined %s\n", substr($a[$k], 6,
  218.  
  219.               length($a[$k]) - 6);
  220.             }
  221.         }
  222.         printf "\@index useitem %s\n", $sorted{$j};
  223.         delete $sorted{$j};
  224.         }
  225.         print '@index enduses';
  226.     }
  227.     if ($defout{$thischunk} == 1) {
  228.         if ($defcount{$thischunk} > 1) {
  229.         print '@xref begindefs';
  230.         $n = (@a = split(' ', $defanchors{$thischunk}));
  231.         for ($j = 2; $j <= $n; $j++) {
  232.             printf "\@xref defitem %s\n", $a[$j];
  233.         }
  234.         print '@xref enddefs';
  235.         }
  236.         if ($uses{$thischunk} ne '') {
  237.         print '@xref beginuses';
  238.         $n = (@a = split(' ', $uses{$thischunk}));
  239.         for ($j = 1; $j <= $n; $j++) {
  240.             printf "\@xref useitem %s\n", $a[$j];
  241.         }
  242.         print '@xref enduses';
  243.         }
  244.         else {
  245.         printf "\@xref notused %s\n", $thischunk;
  246.         }
  247.     }
  248.     if ($defout{$thischunk} > 1) {
  249.         printf "\@xref prevdef %s\n", &listget($defanchors{$thischunk},
  250.  
  251.           $defout{$thischunk} - 1);
  252.     }
  253.     if ($defout{$thischunk} < $defcount{$thischunk}) {    
  254.         printf "\@xref nextdef %s\n", &listget($defanchors{$thischunk},
  255.  
  256.           $defout{$thischunk} + 1);
  257.     }
  258.     print $line;
  259.     }
  260.     elsif ($line =~ /^\@text /) {
  261.     # grotesque hack to get indexes in HTML
  262.     if ($thischunk eq '') {
  263.         # docs mode
  264.         $arg = substr($line, 7, 999999);
  265.         if ($arg eq '<nowebchunks>') {
  266.         &lognowebchunks();
  267.         }
  268.         elsif ($arg eq '<nowebindex>') {
  269.         &lognowebindex();
  270.         }
  271.         else {
  272.         print $line;
  273.         }
  274.     }
  275.     else {
  276.         print $line;
  277.     }
  278.     }
  279.     else {
  280.     print $line;
  281.     }
  282.     delete $lines{$i};
  283. }
  284. if (!$delay) {
  285.     print '@nl';
  286.     print '@nl';
  287.     &lognowebchunks();
  288.     &lognowebindex();
  289. }
  290.  
  291. sub insertafter {
  292.     local($i, $S, $n) = @_;
  293.     for ($n = $nextline++; $n - 1 > $i; $n--) {
  294.     $lines{$n} = $lines{$n - 1};
  295.     }
  296.     $lines{$n} = $S;
  297. }
  298.  
  299. sub slipin {
  300.     local($S) = @_;
  301.     $lines{$nextline++} = $S;
  302. }
  303.  
  304. sub newdefnlabel {
  305.     local($arg, $label) = @_;
  306.     $defcount{$arg} = $defcount{$arg} + 1;
  307.     $label = 'NW' . $curfile . '-' . &uniqueid($arg) . '-' .
  308.  
  309.       &alphacode($defcount{$arg});
  310.     $label;
  311. }
  312.  
  313. sub newdocslabel {
  314.     $newdocslabelcount++;
  315.     'NWD' . &alphacode($newdocslabelcount);
  316. }
  317.  
  318. sub addlabel {
  319.     local(*tbl, $arg, $label, $marker) = @_;
  320.     $marker = ' ' . $label;
  321.     if (!&tailmatch($tbl{$arg}, $marker)) {
  322.     $tbl{$arg} = $tbl{$arg} . $marker;
  323.     }
  324.     $label;
  325. }
  326.  
  327. sub tailmatch {
  328.     local($string, $tail, $pos) = @_;
  329.     $pos = length($string) - length($tail) + 1;
  330.     if ($pos > 0 && substr($string, $pos, 999999) eq $tail) {    
  331.     return 1;
  332.     }
  333.     else {
  334.     return 0;
  335.     }
  336. }
  337.  
  338. sub addud {
  339.     local(*udlist, $name, $arg, $label, $S) = @_;
  340.     $S = ' ' . $name . '{' . $label . '}';
  341.     if (!&tailmatch($udlist{$arg}, $S)) {
  342.     $udlist{$arg} = $udlist{$arg} . $S;
  343.     }
  344. }
  345.  
  346. sub listget {
  347.     local($l, $i, $n, *a) = @_;
  348.     $n = (@a = split(' ', $l));
  349.     $a[$i];
  350. }
  351.  
  352. sub uniqueid {
  353.     local($name, $key) = @_;
  354.     if ($uidtable{$name} eq '') {
  355.     $key = &make_key($name);
  356.     $key =~ s/[\]\[ \\{}`#%&~_^<>"\-]/*/g;
  357.     $keycounts{$key} = $keycounts{$key} + 1;
  358.     $uidtable{$name} = $key;
  359.     if ($keycounts{$key} > 1) {
  360.         $uidtable{$name} = $uidtable{$name} . '.' .
  361.  
  362.           &alphacode($keycounts{$key});
  363.     }
  364.     }
  365.     $uidtable{$name};
  366. }
  367.  
  368. sub make_key {
  369.     local($name, $key, $l) = @_;
  370.     $l = length($name);
  371.     $name =~ s/^.*\///;
  372.     $key = substr($name, 1, 3);
  373.     if ($l >= 3) {
  374.     $key = $key . &alphacode($l);
  375.     }
  376.     $key;
  377. }
  378.  
  379. sub lognowebchunks {
  380.     local($l, $j, $n, $X) = @_;
  381.     if ($loggednowebchunks > 0) {
  382.     return;
  383.     }
  384.     $loggednowebchunks = 1;
  385.     delete $allchunks{0};
  386.     $n = &alphasort(*allchunks);
  387.     print '@xref beginchunks';
  388.     for ($j = 0; $j < $n; $j++) {
  389.     $name = $sorted{$j};
  390.     delete $sorted{$j};
  391.     printf "\@xref chunkbegin %s %s\n", 
  392.     ($anchorlabel{$name} ne '' ? $anchorlabel{$name} : 'nw\@notdef'),
  393.  
  394.       $name;
  395.     $M = (@a = split(' ', $chunkud{$name}));
  396.     for ($k = 1; $k <= $M; $k++) {
  397.         if ($a[$k] =~ /^use/) {
  398.         printf "\@xref chunkuse %s\n", substr($a[$k], 5,
  399.  
  400.           length($a[$k]) - 5);
  401.         }
  402.         elsif ($a[$k] =~ /^defn/) {
  403.         printf "\@xref chunkdefn %s\n", substr($a[$k], 6,
  404.  
  405.           length($a[$k]) - 6);
  406.         }
  407.     }
  408.     print '@xref chunkend';
  409.     }
  410.     print '@xref endchunks';
  411. }
  412.  
  413. sub lognowebindex {
  414.     local($l, $j, $n, $X) = @_;
  415.     if ($loggednowebindex > 0) {
  416.     return;
  417.     }
  418.     $loggednowebindex = 1;
  419.     delete $allidents{0};
  420.     $n = &alphasort(*allidents);
  421.     print '@index beginindex';
  422.     for ($j = 0; $j < $n; $j++) {
  423.     $name = $sorted{$j};
  424.     delete $sorted{$j};
  425.     printf "\@index entrybegin %s %s\n", 
  426.     ($indexanchorlabel{$name} ne '' ? $indexanchorlabel{$name} :
  427.  
  428.       'nw\@notdef'), $name;
  429.     $M = (@a = split(' ', $indexud{$name}));
  430.     for ($k = 1; $k <= $M; $k++) {
  431.         if ($a[$k] =~ /^use/) {
  432.         printf "\@index entryuse %s\n", substr($a[$k], 5,
  433.  
  434.           length($a[$k]) - 5);
  435.         }
  436.         elsif ($a[$k] =~ /^defn/) {
  437.         printf "\@index entrydefn %s\n", substr($a[$k], 6,
  438.  
  439.           length($a[$k]) - 6);
  440.         }
  441.     }
  442.     print '@index entryend';
  443.     }
  444.     print '@index endindex';
  445. }
  446.  
  447. sub alphasort {
  448.     local(*a, $X, $n) = @_;
  449.     $n = 0;
  450.     foreach $X ($[ .. $#a) {
  451.     $n = &insertitem($X, $n);
  452.     }
  453.     $n;
  454. }
  455.  
  456. sub insertitem {
  457.     local($X, $n, $i, $tmp) = @_;
  458.     $sorted{$n} = $X;
  459.     $sortkeys{$n} = &sortkey($X);
  460.     $i = $n;
  461.     while ($i > 0 && ($sortkeys{$i} < $sortkeys{$i - 1} ||     
  462.     $sortkeys{$i} == $sortkeys{$i - 1} && $sorted{$i} lt $sorted{$i - 1})) {    
  463.     $tmp = $sortkeys{$i};
  464.     $sortkeys{$i} = $sortkeys{$i - 1};
  465.     $sortkeys{$i - 1} = $tmp;
  466.     $tmp = $sorted{$i};
  467.     $sorted{$i} = $sorted{$i - 1};
  468.     $sorted{$i - 1} = $tmp;
  469.     $i = $i - 1;
  470.     }
  471.     $n + 1;
  472. }
  473.  
  474. sub sortkey {
  475.     local($name, $S) = @_;
  476.     $S = $name;
  477.     $S =~ s/[^a-zA-Z ]//g;
  478.     $S;
  479. }
  480.  
  481. sub alphacode {
  482.     local($n) = @_;
  483.     if ($n < 0) {
  484.     return '-' . &alphacode(-$n);
  485.     }
  486.     elsif ($n >= $alphacodelen) {    
  487.     return &alphacode($n / $alphacodelen) . &alphacode($n %
  488.  
  489.       $alphacodelen);
  490.     }
  491.     else {
  492.     return substr($alphacodes, $n + 1, 1);
  493.     }
  494. }
  495.